
;
; Save the most recent instructions in a simple ringbuffer for backtrace
; This is a PreScheme package, so it works also with the compiled VM
;
; Usage:
;   - load the debug-package.scm when loading/compiling the VM
;   - open the vm-backtrace package
;   - insert a call to (trace-instruction code pc) in (interpret) in interp.scm
;   - insert a call to (dump-backtrace (current-error-port)) where needed
;
;     The dumped backtrace data is a Scheme vector that can be analyzed using
;     the vm-backtrace-tools package. This is a Scheme package, so it has to
;     be loaded into the VM when it is run as a Scheme program.
;

(define *buffer-size*   500)
(define *buffer-index*    0)
(define *buffer-looped*  #f)

(define *code-buffer*   (make-vector *buffer-size* 0))
(define *pc-buffer*     (make-vector *buffer-size* 0))

; Record the current code+pc for tracing
;
(define (trace-instruction code pc)
  (vector-set! *code-buffer* *buffer-index* code)
  (vector-set! *pc-buffer* *buffer-index* pc)
  (set! *buffer-index* (+ *buffer-index* 1))
  (if (= *buffer-index* *buffer-size*)
    (begin
      (set! *buffer-looped* #t)
      (set! *buffer-index* 0))))

; Clear the backtrace buffer
;
(define (reset-backtrace)
  (set! *buffer-index* 0)
  (set! *buffer-looped* #f))

; Dump the recently executed code vectors in reverse order in the form
; as a vector of pairs (<code vector> . pc), where <code vector> is #f
; if it is the same vector as that of the previous entry.
;
; The result can be passed to disassemble-backtrace in vm-backtrace-tools,
; even in another instance of the VM. This way, debugging of a compiled
; VM-instance using packages such as vm-disassembler is possible
;
(define (dump-backtrace port)
  (write-char #\# port)
  (write-char #\( port)
  (let loop ((looped #f) (i (- *buffer-index* 1)) (previous 0))
    (cond ((and (< i 0) *buffer-looped* (not looped))
           (loop #t (- *buffer-size* 1) previous)) ; restart at end of buffer
          ((or (< i 0) (and looped (< i *buffer-index*)))
           (write-char #\) port)
           (unspecific)) ; really done here
          (else
           (loop looped (- i 1)
             (dump-backtrace-entry previous 
               (vector-ref *code-buffer* i)
               (vector-ref *pc-buffer* i)
               port))))))                  
  
(define (dump-code-vector code port)
  (write-char #\# port)
  (write-char #\( port)
  (do ((i 0 (+ i 1)))
      ((= i (code-vector-length code))
       (write-char #\) port))
    (if (> i 0)
        (begin
          (write-char #\space port)
          (unspecific))
        (unspecific)) ; for type checker
    (write-integer (code-vector-ref code i) port)))

(define (dump-backtrace-entry previous-code code pc port)
  (if (not (eq? previous-code 0))
      (begin 
        (write-char #\space port)
        (unspecific))
      (unspecific))
  (write-char #\( port)
  (if (eq? previous-code code)
      (write-string "#f" port)
      (dump-code-vector code port))
  (write-char #\space port)
  (write-char #\. port)
  (write-char #\space port)
  (write-integer pc port)
  (write-char #\) port)
  code)

    
    